Shareware Grab Bag/Shareware Grab Bag.iso/050/pxg11.arc/PXG11.PAS

Pascal/Delphi Source File | 1985-10-06 | 13.6 KB | 639 lines

(* -------------------------------------------------------
 *
 *   PXG - A Pascal Expert Generator
 *
 *   By Samuel H. Smith,  Public Domain Material
 *
 *   Version 1.0, 4-Oct-85
 *      Initial public domain release
 *
 *   Version 1.1, 6-Oct-85
 *      This version uses a new, more compact format for .KDB files
 *      and is not compatible with old .KDB files.
 *
 *)

{$D-,U+,R+}


program pascal_expert_generator;

type
   anystring = string[80];

   treeptr = ^tree;           {this is the basic structure of the}
   tree = record              {knowledge base tree}

      question:   anystring;      {question to ask at this node in the tree}
      ifyes:      treeptr;           {subtree if answer is yes}
      ifno:       treeptr;           {subtree if answer is no}

      conclusion: anystring;      {conclusion if there is no question}

   end;



var
   title:  anystring;    {the title of the current knowledge base}

   root:   treeptr;      {the root of the knowledge tree}

   fd:     text[1024];   {file for read/write tree to disk}

   line:   anystring;    {a working line buffer}

   saved:  boolean;      {has the current knowledge base been saved?}



(* -------------------------------------------------------
 *
 *   ask a yes/no question
 *
 *   returns true if the answer is yes
 *
 *)

function ask(question: anystring): boolean;
var
   answer: char;
begin
   repeat
      write(question,' (Y/N) ');

      read(kbd,answer);
      answer := upcase(answer);
      writeln(answer);

      if not (answer in ['Y','N']) then
         writeln('Please answer the question!');

   until answer in ['Y','N'];

   ask := (answer = 'Y');
end;



(* -------------------------------------------------------
 *
 *   make a conclusion
 *
 *)

procedure conclude(conc: anystring);
begin
   writeln;
   writeln('Conclusion: ',conc);
   writeln;
end;



(* -------------------------------------------------------
 *
 *   learn a new rule
 *
 *   entered when an incorrect conclusion is drawn
 *   moves the current conclusion down the 'no' branch of the tree
 *   makes a new question and moves it's conclusion down the 'yes' branch
 *
 *)

procedure learn(var node: treeptr);
var
   temptree: treeptr;

begin
   saved := false;

   with node^ do
   begin
      new(ifno);       {initialize the new subtrees}
      with ifno^ do
      begin
         ifyes      := nil;
         ifno       := nil;
         question   := node^.question;    {the ifno subtree inherits the}
         conclusion := node^.conclusion;  {question and conclusion that}
      end;                                {used to be at this node}

      new(ifyes);
      with ifyes^ do
      begin
         ifyes      := nil;
         ifno       := nil;
         question   := '';
      end;


      {now gather the information needed to enter a new question and
       conclusion into the tree}

      writeln;
      writeln('Please enter the correct conclusion:');
      write('> ');
      readln(conclusion);
      ifyes^.conclusion := conclusion;

      repeat
         writeln;
         writeln('Please enter a new question.  Phrase the question');
         writeln('so that when answered "yes" it gives the conclusion: ');
         writeln('   ',ifyes^.conclusion);
         writeln('and that when answered "no" gives the conclusion:');
         writeln('   ',ifno^.conclusion);

         writeln;
         writeln('Enter "X" to exchange the "yes" and "no" conclusions,');
         writeln('otherwise enter the actual question.');
         write('> ');
         readln(question);
         question[1] := upcase(question[1]);
         writeln;

         if question = 'X' then
         begin
            temptree := ifno;
            ifno := ifyes;
            ifyes := temptree;
         end;

      until question <> 'X';
   end;
end;



(* -------------------------------------------------------
 *
 *   solve a problem with a knowledge tree
 *
 *   makes a conclusion if there is no question in the current node.
 *   otherwise, it asks the question and then tries to solve
 *   the remaining subtree.
 *   will learn a new fact if an incorrect conclusion is drawn.
 *
 *)

procedure solvetree(node: treeptr);
begin
   with node^ do
   begin
      if question <> '' then   {ask the question if there is one}
      begin
         if ask(question) then
            solvetree(ifyes)      {decide which branch of the tree}
         else                     {to solve based on the answer}
            solvetree(ifno);
      end
      else

      begin           {there is no question; just make a conclusion}
         conclude(conclusion);

         if ask('Is this the right conclusion?') = false then
            learn(node);
      end;

   end;
end;



(* -------------------------------------------------------
 *
 *   list all of the knowledge contained in a knowledge tree
 *
 *)

procedure disptree(level: integer;  node: treeptr);
begin
   with node^ do
   begin
      if question <> '' then
      begin
         writeln('':level,'If ''',question,''' is true:');
         disptree(level+3,ifyes);

         writeln;
         writeln('':level,'If ''',question,''' is false:');
         disptree(level+3,ifno);
      end
      else
         writeln('':level,conclusion)
   end;
end;



(* -------------------------------------------------------
 *
 *   write a node in the knowledge tree to a file
 *
 *)

procedure writenode(level: integer; node: treeptr);
begin
   with node^ do
   begin
      if question <> '' then
      begin
         writeln(fd,'Q:',question);
         write(fd,'':level,'Y');
         writenode(level+1,ifyes);

         write(fd,'':level,'N');
         writenode(level+1,ifno);
      end
      else
         writeln(fd,'C:',conclusion);
   end;
end;



(* -------------------------------------------------------
 *
 *   write the entire knowledge tree to a file
 *
 *)

procedure writetree;
begin
   write('Enter the name of the file to write to [.KDB]: ');
   readln(line);
   if line = '' then
      exit;

   if pos('.',line) = 0 then
      line := line + '.KDB';

   assign(fd,line);

{$I-}
   rewrite(fd);
   writeln(fd,title);
   writenode(0,root);
   close(fd);

   if ioresult <> 0 then
      writeln('Error writing file!')
   else
      saved := true;
{$I+}

end;



(* -------------------------------------------------------
 *
 *   read a node of the knowledge tree from a file
 *   and verify that the file is valid
 *
 *)

procedure readnode(node: treeptr);
var
   c: char;

   procedure expect(message: anystring);
   begin
      repeat
         read(fd,c);
      until c <> ' ';

      if c <> message then
         writeln('"',message,'" expected, "',c,'" found.');
   end;

begin
   with node^ do
   begin

      read(fd,c);
      if c = 'Q' then
      begin
         conclusion := '';
         expect(':');
         readln(fd,question);

         expect('Y');
         new(ifyes);
         readnode(ifyes);

         expect('N');
         new(ifno);
         readnode(ifno);
      end
      else

      begin
         if c <> 'C' then
            writeln('"C" expected, "',c,'" found.');

         expect(':');
         readln(fd,conclusion);
      end;
   end;
end;



(* -------------------------------------------------------
 *
 *   read a new knowledge tree from a file
 *
 *)

procedure readtree;
begin

   {if there is anything in the current knowledge tree, then see if}
   {the user wants to save it}

   if not saved then
      if ask('Do you want to save the current knowledge base?') then
         writetree;

   write('Enter the name of the file to read from [.KDB]: ');
   readln(line);
   if line = '' then
      exit;

   if pos('.',line) = 0 then
      line := line + '.KDB';

   assign(fd,line);

{$I-}
   reset(fd);
   if ioresult <> 0 then
      writeln('File not found!')
   else

   begin
      readln(fd,title);
      readnode(root);
      close(fd);
   end;

   if ioresult <> 0 then
      writeln('Error reading file!');
{$I+}

   saved := true;

end;




(* -------------------------------------------------------
 *
 *   generate a program fragment for the current node in the knowledge tree
 *
 *)

procedure prognode(level: integer;  node: treeptr);
begin
   with node^ do
   begin
      if question <> '' then
      begin
         writeln(fd,'':level,'if ask(''',question,''') = true then');
         prognode(level+3,ifyes);

         writeln(fd);
         writeln(fd,'':level,'else    {',question,' = false}');
         prognode(level+3,ifno);
      end
      else
         writeln(fd,'':level,'conclude(''',conclusion,''')');
   end;
end;



(* -------------------------------------------------------
 *
 *   generate a program to walk the knowledge tree
 *
 *)

procedure progtree;
begin
   write('Enter the name of the file to save the program in [.PAS]: ');
   readln(line);
   if line = '' then
      exit;

   if pos('.',line) = 0 then
      line := line + '.PAS';

   assign(fd,line);

{$I-}
   reset(fd);
{$I+}

   if ioresult = 0 then
   begin
      close(fd);
      if ask('The file '+line+' exists!   Overwrite it?') = false then
         exit;
   end;

{$I-}
   rewrite(fd);
   writeln(fd);
   writeln(fd,'{Expert program ',line,' generated by PXG}');
   writeln(fd);
   writeln(fd,'{$I PXG.INC}');
   writeln(fd);
   writeln(fd,'begin');
   writeln(fd,'   repeat');
   writeln(fd,'      writeln;');
   writeln(fd,'      writeln(''',title,''');');
   writeln(fd,'      writeln;');
   writeln(fd);
   prognode(6,root);
   writeln(fd);
   writeln(fd,'   until ask(''Run again?'') = false;');
   writeln(fd,'end.');
   close(fd);

   if ioresult <> 0 then
      writeln('Error writing file!')
   else

   begin
      writeln;
      writeln('Use Turbo Pascal to compile ',line);
      writeln;
   end;

{$I+}

end;



(* -------------------------------------------------------
 *
 *   initialize a new knowledge tree
 *
 *)

procedure inittree;
begin
   new(root);
   with root^ do
   begin
      ifyes      := nil;
      ifno       := nil;
      question   := '';
      conclusion := 'No conclusion';
   end;

   saved := true;
   title := 'Default knowledge base';

end;



(* -------------------------------------------------------
 *
 *   initialize a new knowledge tree
 *
 *)

procedure newtree;
begin

   {if there is anything in the current knowledge tree, then see if}
   {the user wants to save it}

   if not saved then
      if ask('Do you want to save the current knowledge base?') then
         writetree;

   writeln('Enter the title of the new expert:');
   write('> ');
   readln(title);

end;



(* -------------------------------------------------------
 *
 *   help - give some help
 *
 *)

procedure help;
begin
   clrscr;
   writeln;
   writeln('PXG - A Pascal Expert Generator');
   writeln;
   writeln('This program allows you to prepare a set of rules for a');
   writeln('decision-tree based expert system.');
   writeln;
   writeln('You teach the expert by repeatedly "Learning" new facts. ');
   writeln('When you have your rules working properly, you can generate ');
   writeln('a stand-alone expert program in turbo pascal!');
   writeln;
   writeln('Actions:');
   writeln('   New          Create a new knowledge base');
   writeln('   Read         Read a knowledge base from a disk file');
   writeln('   Write        Write the current knowledge base to a file');
   writeln('   Display      Display the rules in the current knowledge base');
   writeln('   Program      Generate an expert program from this knowledge base');
   writeln('   Learn        Test this knowledge base and learn new rules');
   writeln('   Quit         Exit to the system');
   writeln;

end;



(* -------------------------------------------------------
 *
 *   main program
 *   select expert commands and process them
 *
 *)

var
   command:  char;

begin
   clrscr;
   writeln;
   writeln('PXG - A Pascal Expert Generator');
   writeln;
   writeln('This program allows you to prepare a set of rules for a');
   writeln('decision-tree based expert system.');
   writeln;
   writeln('You teach the expert by repeatedly "Learning" new facts. ');
   writeln('When you have your rules working properly, you can generate ');
   writeln('a stand-alone expert program in turbo pascal!');
   writeln;
   writeln('By Samuel H. Smith,  Public Domain Material');
   writeln('Version 1.1, 6-Oct-85');

   sound(3000);
   delay(100);
   nosound;

   delay(3000);
   help;

   inittree;

   repeat
      writeln;
      writeln('Working on:');
      writeln('   ',title);
      writeln;
      write('Action:  New, Read, Write, Display, Program, Learn, Quit, ?: ');

      read(kbd,command);
      command := upcase(command);
      writeln(command);
      writeln;

      case command of
         'N':  newtree;
         'R':  readtree;
         'W':  writetree;
         'D':  disptree(3,root);
         'P':  progtree;
         'L':  solvetree(root);
         '?':  help;
         'Q':  ;

         else  writeln('What?   Type "?" for help.');
      end;

   until command = 'Q';


   {if there is anything in the current knowledge tree, then see if}
   {the user wants to save it}

   if not saved then
      if ask('Do you want to save the current knowledge base?') then
         writetree;

   writeln('Goodbye.');
end.